(setq %docs {})

(setq %setf-fcts {})

(setq %put-doc
  (fct (sym val)
    (nput %docs sym val)))

(setq %get-doc
  (fct (sym) (%docs sym)))

(%putd 'defmac 3
       (fct (name args . body)
        (let (doc (if (and (cdr body) (isa (car body) str-t))
                    (let b1 (car body)
                      (setq body (cdr body))
                      b1))
              qn (list 'quote name))
          `(do
             (%putd ,qn 3 (fct ,args ,@body))
             (if ,doc
               (%put-doc ,qn ,doc))
             ,qn)
) ) )

(defmac defct (name args . body)
  (let (doc (if (and (cdr body) (isa (car body) str-t))
              (let b1 (car body)
                (setq body (cdr body))
                b1))
        qn (list 'quote name)
        expr (if (and (isa name cons-t) (is (car name) 'setf)
                      (isa (cadr name) symbol-t) (not (cddr name)))
               (let fname (cadr name)
                 `(nput %setf-fcts
                        ,(if (or (%symtst fname 1) (macro-fct fname))
                           (list 'quote fname)
                           `(fct-name ,fname))
                        ,(if body `(fct ,args ,@body) args)))
               `(do
                  (%putd ,qn 0 (fct ,args ,@body))
                  (if ,doc
                    (%put-doc ,qn ,doc)))))
    `(do
       ,expr
       ,qn)))

(let m (:macro (n1 code)
         (list '%putd n1 3
           (fct (name value (doc nil))
             (let qn (list 'quote name)
               (list
                 'do
                 (list '%putd qn code value)
                 (list 'if doc (list '%put-doc qn doc))
                 qn)))))
  (m 'defvar 2)
  (m 'defalias 4))

(defmac defconst (name value (doc nil))
  (let (qn (list 'quote name)
        nv (macroexp value)
        code (if (or (isa nv int-t float-t char-t bvector-t)
                     (and (isa nv cons-t)
                          (is (car nv) 'quote)
                          (do
                            (setq nv (car (cdr nv)))
                            t)))
               6
               1))
    `(do
       (%putd ,qn ,code ,nv)
       (if ,doc
         (%put-doc ,qn ,doc))
       ,qn)))

(defct cddr (x) (cdr (cdr x)))
(defct caar (x) (car (car x)))
(defct cadr (x) (car (cdr x)))
(defct cdar (x) (cdr (car x)))

(defct caaar (x) (car (car (car x))))
(defct cdddr (x) (cdr (cdr (cdr x))))
(defct cadar (x) (car (cdr (car x))))
(defct cdaar (x) (cdr (car (car x))))
(defct caddr (x) (car (cdr (cdr x))))
(defct cdaar (x) (cdr (car (car x))))
(defct cdadr (x) (cdr (car (cdr x))))
(defct cddar (x) (cdr (cdr (car x))))

;; Type predicates.

(defct int-p (x) (isa x int-t))
(defct char-p (x) (isa x char-t))
(defct list-p (x) (isa x cons-t))
(defct cons-p (x) (and x (list-p x)))
(defct float-p (x) (isa x float-t))
(defct bvector-p (x) (isa x bvector-t))
(defct str-p (x) (isa x str-t))
(defct array-p (x) (isa x array-t))
(defct table-p (x) (isa x table-t))
(defct tuple-p (x) (isa x tuple-t))
(defct symbol-p (x) (isa x symbol-t))
(defct fct-p (x) (isa x fct-t))
(defct coro-p (x) (isa x coro-t))
(defct pkg-p (x) (isa x pkg-t))

;; tests on symbols
(defct const-p (sym) (%symtst sym 0))
(defct specform-p (sym) (%symtst sym 1))
(defct special-p (sym) (%symtst sym 2))
(defct macro-p (sym) (%symtst sym 3))
(defct alias-p (sym) (%symtst sym 4))
(defct literal-p (sym) (%symtst sym 5))
(defct bound-p (sym) (%symtst sym 6))

(defmac if-not (cond then (else nil))
  `(if (not ,cond)
     ,then
     ,else))

(defmac when (cond . body)
  `(if ,cond
     (do
       ,@body)))

(defmac unless (cond . body)
  `(if (not ,cond)
     (do
       ,@body)))

(defmac until (cond . body)
  `(while (not ,cond)
     ,@body))

(defct docs (sym)
  (%docs sym))

(defct iter (x)
  (if (coro-p x)
    x
    (let (fn %iter it (fn x))
      (while it
        (yield (fn x it))
        (setq it (fn x it t)))
      nil)
) )

(defct %table-iter (tab it-fn)
  (let (fn %iter it (fn tab))
    (while it
      (yield (it-fn it))
      (setq it (fn tab it t))
) ) )

(defct table-keys (tab)
  (%table-iter tab (fct (x) (x 0))))

(defct table-values (tab)
  (%table-iter tab (fct (x) (x 1))))

(defct table-items (tab)
  (%table-iter tab (fct (x) (list (x 0) (x 1)))))

(defmac each (val seq . body)
  (let it (gensym)
    `(let ,it (iter ,seq)
       (while ,it
         (let ,val (coro-val ,it)
           ,@body)
         (setq ,it (coro-next ,it)))
) ) )

(defct %min-max (comp x y args)
  (let rv (if (comp x y) x y)
    (while args
      (let val (car args)
        (if (comp val rv)
          (setq rv val))
        (setq args (cdr args))))
    rv))

(defct min (x y . args)
  (%min-max < x y args))

(defct max (x y . args)
  (%min-max > x y args))

(defmac use (name (pull-or-as nil) (syms nil))
  `(%use ,(if (symbol-p name) (symname name) name)
         ,pull-or-as ,(if syms
                        (list 'quote syms))))

(defconst ROOT-PKG (sympkg '::a))

(defconst KWORD-PKG (sympkg :as))

(defct kword-p (x)
  (and (symbol-p x) (is KWORD-PKG (sympkg x))))

(defct kword (name)
  (intern name KWORD-PKG))

(defct dotted-list-p (x)
  (if (list-p x)
    ((fct (lst)
       (and lst
         (or (not (cons-p lst)) (recur (cdr lst)))))
     x)
) )

;; deftype

(defct %slotspec (spec)
  (if-not (list-p spec)
    (list 'quote spec)
    `(list ',(car spec) ,@((fct (sdef acc)
                             (if-not sdef
                               (nreverse acc)
                               (let spec (car sdef)
                                 (recur (cddr sdef)
                                   (let spec (car sdef)
                                     (list* (if (is spec :init)
                                             `(fct () ,(cadr sdef))
                                             (cadr sdef))
                                           spec
                                           acc))))))

                           (cdr spec) nil)
) ) )

(defmac deftype (name bases . slots)
  (let (qn (list 'quote name)
        rbases (if bases `(list ,@bases)))
    `(%putd ,qn 5
            (type ,qn ,rbases
                  (list ,@((fct (lst acc)
                             (if-not lst
                               (nreverse acc)
                               (recur (cdr lst)
                                      (cons (%slotspec (car lst)) acc))))
                           slots nil)))
) ) )

;; define exception types

(deftype exception ()
  (msg :type str-t))

(deftype arg-error (exception))
(deftype type-error (exception))
(deftype arith-error (exception))
(deftype intr-error (exception))
(deftype unbound-error (exception))
(deftype dispatch-error (exception))
(deftype parse-error (exception))
(deftype const-error (exception))

;; Runtime hook.
(defct %mkexc (name msg)
  (make (symval (intern name ROOT-PKG)) :msg msg))

(defct error (typ msg . args)
  (raise (#'make typ :msg msg args)))

;; setf implementation

(defct setf-fct (fname (ret-dfl nil))
  (let rv (%setf-fcts fname)
    (or rv (and ret-dfl (fct (val place key)
                          (nput place key val))))))

(defct %expand-setf-cons (place val)
  (let (first (car place) setter (and (symbol-p first) (%setf-fcts first)))
    (if-not setter
      (let m-expr (macroexp-1 place)
        (if-not (is m-expr place)
          (return (recur m-expr val)))))
    (let (gen-gs (fct (n acc)
                   (if (is n 0)
                     acc
                     (recur (- n 1) (cons (gensym) acc))))
          ilv (fct (l1 l2 acc)
                (if-not l1
                  acc
                  (recur (cdr l1) (cdr l2)
                         (list* (car l2) (car l1) acc))))
          gval (gensym))
      (if
        (not setter)
          (let gsyms (gen-gs (len place) nil)
            `(let (,@(ilv place gsyms nil) ,gval ,val)
               (if (fct-p ,(car gsyms))
                 ((setf-fct (fct-name ,(car gsyms))) ,gval ,@(cdr gsyms))
                 (nput ,@gsyms ,gval))))

        (or (specform-p first) (macro-fct first))
          (setter val (cdr place))
          (let gsyms (gen-gs (- (len place) 1) nil)
            `(let (,@(ilv (cdr place) gsyms nil) ,gval ,val)
               (,setter ,gval ,@gsyms)))
) ) ) )

(defct %setf-const-multi (val)
  (if
    (array-p val)
      (list val (fct (x) x))
    (not (cons-p val))
      nil
    (and (is 'quote (car val)) (cons-p (cadr val))
         (not (dotted-list-p (cadr val))))
      ;; same as with an array, but we must quote elements.
      (list (cadr val) (fct (x) (list 'quote x)))
      nil
) )

(defct %expand-setf-array-const (place val fn)
  (let (p-len (len place) v-len (len val)
        i 0 expr nil len-m1 (- p-len 1))
    (if
      (is len-m1 -1)
        (error arg-error "empty variable list")
      (and (> p-len v-len) (not (kword-p (place -1))))
        (error arg-error "too few values to unpack")
      (and (< p-len v-len) (not (kword-p (place -1))))
        (error arg-error "too many values to unpack"))
    (while (< i len-m1)
      (if (kword-p (place i))
        (error arg-error "keywords must appear at the end"))
      (setq expr (cons (%expand-setf (place i) (fn (val i))) expr))
      (setq i (+ i 1)))
    (setq expr (cons (if (kword-p (place i))
                       (list 'setq (intern (symname (place i)))
                             (if-not (= (len val) i) (fn (subseq val i))))
                       (%expand-setf (place i) (fn (val i))))
                     expr))
    `(do
       ,@(nreverse expr))))

(defct %expand-setf-array (place val)
  (let cx (%setf-const-multi val)
    (if cx
      ;; The form's type is known at compile time. Instead of
      ;; dynamically generating assignments with coroutines,
      ;; we can assign items individually.
      (return (%expand-setf-array-const place (car cx) (cadr cx)))))
  (let (g (gensym) ln (- (len place) 1)
        i 0 rv nil
        ival-expr (list 'coro-val g)
        inext-expr `(if-not (setq ,g (coro-next ,g))
                      (error arg-error "too few values to unpack")))
    (if (is ln -1)
      (error arg-error "empty variable list"))
    (while (< i ln)
      (if (kword-p (place i))
        (error arg-error "keywords must appear at the end"))
      (setq rv (list* inext-expr (%expand-setf (place i) ival-expr) rv))
      (setq i (+ i 1)))
    (setq rv (if (kword-p (place i))
               (cons `(setq ,(intern (symname (place i)))
                        (tolist (coro-next ,g)))
                     (cdr rv))
               (list* `(if (coro-next ,g)
                         (error arg-error "too many values to unpack"))
                      (%expand-setf (place i) ival-expr)
                      rv)))
    `(let ,g (iter ,val)
      ,@(nreverse rv))
) )

(defct %expand-setf (place val)
  (if
    (symbol-p place)
      (list 'setq place val)
    (array-p place)
      (%expand-setf-array place val)
    (cons-p place)
      (%expand-setf-cons place val)
      (error arg-error "invalid place: ${place}")))

(defmac setf (place val . rest)
  (if-not rest
    (%expand-setf place val)
    (let rv (list (%expand-setf place val))
      (while rest
        (let (p2 (car rest) v2 (cdr rest))
          (if
            (not v2)
              (error arg-error "odd number of arguments")
            (not (cons-p v2))
              (error arg-error "got a dotted list"))
          (setq rv (cons (%expand-setf p2 (car v2)) rv))
          (setq rest (cdr (cdr rest)))))
      `(do ,@(nreverse rv))
) ) )

(defct (setf car) nputcar)
(defct (setf cdr) nputcdr)

(defct (setf apply) (value fn . args)
  (apply (%setf-fcts (fct-name fn)) value (subseq args 0 -1)))

(defct (setf symval) (value sym)
  (%putd sym 5 value))

(defct (setf docs) (val sym)
  (if
    (not (str-p val))
      (error type-error "(setf docs): first argument must be a string")
    (not (symbol-p sym))
      (error type-error "(setf docs): second argument must be a symbol"))
  (nput %docs sym val))

(defct str (x . args)
  (#'print-to "" x args))

(defct ensure-type (x typ)
  (if-not (isa x typ)
    (error type-error "argument is not of type ${typ}")
    x))

;; These must be defined after setf.

(defct all (pred seq)
  (each val seq
    (if-not (pred val)
      (return nil)))
  t)

(defct any (pred seq)
  (each val seq
    (if (setq val (pred val))
      (return val)))
  nil)

(defct most (pred seq)
  (let (full 0 match 0 + +)
    (each val seq
      (if (pred val)
        (setq match (+ match 1)))
      (setq full (+ full 1)))
    (> (+ match match) full)))

(defct tolist (x)
  (if
    (list-p x) (copy x)
    (array-p x) (apply list x)
    (let ret nil
      (each val x
        (setq ret (cons val ret)))
      (nreverse ret))))

(defct toarray (x)
  (if
    (array-p x) (copy x)
    (list-p x) (apply array x)
    (let ret nil
      (each val x
        (setq ret (cons val ret)))
      (apply array (nreverse ret)))))

(defconst NZAP-NOMT 1
  "specify that nzap doesn't need to be multi-thread safe")

(defconst NZAP-DFL 2
  "specify that the first of the rest arguments for nzap is the default")

(defconst NZAP-PREV 4
  "specify that nzap should return the value previous to the update")

(defct %zapf-args (args)
  (let (vals nil)
    (while args
      (let elem (macroexp (car args))
        (if (symbol-p elem)
          (setq vals (cons elem vals)))
        (setq args (cdr args))))
    (nreverse vals)))

(defct %zapf-fn (fn flags cb prev . args)
  (if
    (is fn car)
      (#'nzap (ensure-type (car args) cons-t) 0 flags cb (cdr args))
    (is fn symval)
      (#'nzap (sympkg (car args)) (symname (car args))
              flags cb (cdr args))
    (is fn docs)
      (#'nzap %docs (car args) flags cb (cdr args))
    (let (name (fct-name fn) setter (setf-fct name))
      (if-not setter
        (error arg-error "no setter defined for ${name}")
        (let (pval (#'fn args)
              rv (setter (cb pval) (car args)))
          (if prev pval rv)))
) ) )

(defct %zapf-expand (place prev args first expr)
  (let (ln (len place)
        syms (%zapf-args args)
        fn `(fct (,first ,@syms) ,expr))
    (if
      (is ln 2)
        `(nzap ,(car place) ,(cadr place)
               ,(if prev NZAP-PREV 0) ,fn ,@syms)
      (is ln 3)
        `(nzap ,(car place) ,(cadr place)
               ,(+ NZAP-DFL (if prev NZAP-PREV 0))
               ,fn ,(caddr place) ,@syms)
      `(error arg-error "wrong number of arguments for 'zapf'"))))

(defct %zapf-helper (orig-place expr prev args)
  (let (place (macroexp orig-place)
        first #\it)
    (if
      (symbol-p place)
        (if prev
          (let gs (gensym)
            `(let (,gs ,place ,first (:alias ',place))
               (setq ,place ,expr)
               ,gs))
          `(let ,first (:alias ',place)
             (setq ,place ,expr)))
      (not (cons-p place))
        (error arg-error "first argument must be a symbol or cons")
      (let head (car place)
        (if
          (is head 'car)
            (%zapf-expand (list* `(ensure-type ,(cadr place) cons-t)
                                 0 (cddr place))
                          prev args first expr)
          (is head 'symval)
            (let gs (gensym)
              `(let ,gs ,(cadr place)
                 ,(%zapf-expand (list* `(sympkg ,gs) `(symname ,gs)
                                       (cddr place))
                                prev args first expr)))
          (is head 'docs)
            (%zapf-expand (list* '%docs (cdr place))
                          prev args first expr)
          (let (gs (gensym)
                flags (+ (if prev NZAP-PREV 0) (if (cddr place) NZAP-DFL 0)))
            `(let ,gs ,(car place)
               (if (fct-p ,gs)
                 (%zapf-fn ,gs ,flags
                           (fct (,first) ,expr) ,prev ,@(cdr place))
                 ,(%zapf-expand place prev args first expr)))))
) ) ) )

(defmac zapf (place expr (:args nil))
  (%zapf-helper (macroexp place) expr nil args))

(defmac pre-zapf (place expr (:args nil))
  (%zapf-helper (macroexp place) expr t args))

(defmac addf (place (val 1))
  (let plus +
    `(zapf ,place (,plus ,#\it ,val) :args (,val))))

(defmac subf (place (val 1))
  (let minus -
    `(zapf ,place (,minus ,#\it ,val) :args (,val))))

(defmac pre-addf (place (val 1))
  (let plus +
    `(pre-zapf ,place (,plus ,#\it ,val) :args (,val))))

(defmac pre-subf (place (val 1))
  (let minus -
    `(pre-zapf ,place (,minus ,#\it ,val) :args (,val))))

(defmac pushf (place val)
  (let arg #\it
    `(zapf ,place (if (::list-p ,arg)
                    (cons ,val ,arg)
                    (::g-push ,arg ,val)) :args (,val))))

(defvar *pop-value* nil)

(defct %pop-impl (place)
  (if (list-p place)
    (do
      (setq *pop-value* (car place))
      (cdr place))
    (let (tmp (g-pop place)
          ret (tmp 0) seq (tmp 1))
      (setq *pop-value* ret)
      seq)))

(defmac popf (place . rest)
  (if-not rest
    `(let ::*pop-value* nil
       (zapf ,place (::%pop-impl ,#\it))
       ::*pop-value*)
    `(npop ,place ,(car rest) ,@(cdr rest))))

;; Like pushf and popf, but optimized for lists.
(defmac lpushf (place val)
  `(zapf ,place (cons ,val ,#\it) :args (,val)))

(defmac lpopf (place)
  (let arg #\it
    `(let ::*pop-value* nil
       (zapf ,place
             (do
               (setf ::*pop-value* (car ,arg))
               (cdr ,arg)))
       ::*pop-value*)))

(defmac catch (name . clauses)
  (if
    (not (symbol-p name))
      (error type-error "name must be a symbol")
    (not clauses)
      (error arg-error "at least one clause is needed"))
  (let (le-fn last-err
        err-spec (gensym))
    (if-not (cdr clauses)
      `(let ,name (,le-fn)
         ,(car clauses))
      `(let (,err-spec (,le-fn t)
             ,name (car ,err-spec))
         (if
           ,@((fct (nm espec curr acc)
                (if (not curr)
                  (nreverse (cons `(raise (car ,espec) (cadr ,espec)) acc))
                  (let elem (car curr)
                    (if-not (cdr curr)
                      (nreverse (cons elem acc))
                      (recur nm
                             espec
                             (cddr curr)
                             (list* (cadr curr)
                                    `(isa ,nm
                                          ,@(if (list-p elem)
                                             elem
                                             (list elem)))
                                    acc))))))
              name err-spec clauses nil)))
) ) )

(defct %map-list (fn lst)
  (let rv nil
    (while lst
      (lpushf rv (fn (car lst)))
      (setq lst (cdr lst)))
    (nreverse rv)))

(defmac case (value . clauses)
  (let gs (gensym)
    `(let ,gs ,value
       (if ,@((fct (curr name acc)
                (if (not curr)
                  (nreverse (cons '(error arg-error "no clause matched") acc))
                  (let elem (car curr)
                    (if (not (cdr curr))
                      (nreverse (cons elem acc))
                      (recur (cddr curr)
                             name
                             (list* (cadr curr)
                                    (if (cons-p elem)
                                      (cons 'or
                                            (%map-list (fct (q)
                                                         (list '=
                                                               (list 'quote q)
                                                               name))
                                                       elem))
                                      (list '= elem name))
                                   acc))))))
              clauses gs nil))
) ) )

;; defmeth

(defconst %METH-TOKEN (gensym))

(defct %meth-test (x y)
  (%meth-ctl 0 x y))

(defct %meth-cache ()
  (%meth-ctl 1))

(defct %meth-flag (name meth gfn)
  (%meth-ctl 2 name meth gfn))

(defct %meth-get-argname (arg opt)
  (if (array-p arg)
    (if opt
      (error arg-error "typed parameters cannot follow optionals")
      (if (> (len arg) 2)
        (error arg-error "invalid method argument: ${arg}")
        (arg 0)))
    (if (and (list-p arg) (kword-p (car arg)))
      (list (intern (symname (car arg))))
      arg)))

(defct %meth-args (args opt acc)
  (if (or (not args) (not (list-p args)))
    (if-not opt
      (if args
        (nrevconc acc args)
        (nreverse acc))
      (let (rv (nreverse acc)
            rx rv)
        (while (not (list-p (cadr rx)))
          (setq rx (cdr rx)))
        (nputcdr (caar (cdr rx)) rx)
        rv))
    (let arg (car args)
      (recur (cdr args)
             (or opt (list-p arg))
             (cons (%meth-get-argname arg opt) acc)))))

(defct %meth-types (args acc)
  (if (or (not (list-p args)) (list-p (car args)))
    (nreverse acc)
    (recur (cdr args)
           (cons (let arg (car args)
                   (if (array-p arg)
                     (arg 1)
                     nil))
                 acc))))

(defmac defmeth (name args . body)
  (if (or (not args) (not (list-p args)) (list-p (car args)))
    (error arg-error "method must have at least one required parameter"))
  (let (gval (gensym) gmeth (gensym)
        fct-args (%meth-args args nil nil)
        qn (list 'quote name)
        call-expr (if (dotted-list-p fct-args)
                    (let last-arg (last fct-args)
                      (concat `(apply %meth-ctl 3 ,gval)
                              (subseq fct-args 0 -1)
                              (list (car last-arg) (cdr last-arg))))
                    (list* '%meth-ctl 3 gval fct-args))
        meth-args ((fct (args acc)
                     (if-not (cons-p args)
                       (if args
                         (nrevconc acc args)
                         (nreverse acc))
                       (recur (cdr args)
                              (cons (if (array-p (car args))
                                      ((car args) 0)
                                      (car args))
                                    acc))))
                   args nil))
    `(let ,gmeth (fct ,meth-args
                   (let meth-next (:alias
                                    '(let tmp (cdr ::*meth-curr*)
                                       (fct args
                                         (let ::*meth-curr* tmp
                                           (apply (car tmp) args)))))
                     (let meth-next (:macro args
                                      `(let ::*meth-curr* (cdr ::*meth-curr*)
                                         ((car ::*meth-curr*) ,@args)))
                       ,@body)))
       (%meth-ctl 5
                  (nzap (sympkg ,qn) (symname ,qn) NZAP-DFL
                        (fct (,gval ,gmeth)
                          (if (%meth-test ,gval ,gmeth)
                            ,gval
                            (%meth-flag ,qn ,gmeth
                                        (let ,gval [{} (%meth-cache)]
                                          (fct ,fct-args
                                            (let ::*meth-curr* nil
                                              ,call-expr))))))
                        %METH-TOKEN ,gmeth)
                  (array ,@(%meth-types args nil)) ,gmeth)
) ) )

(defct generic-fct-p (x)
  (not (not (%meth-test x x))))

(defct meth-find (gfn types)
  (let meths (%meth-ctl 4 gfn types)
    (if meths
      (fct args
        (let *meth-curr* meths
          (apply (car meths) args))))))

(defct meth-add (gfn types method)
  (%meth-ctl 5 gfn types method))

(defct meth-del (gfn types)
  (%meth-ctl 6 gfn types))

(defmeth g-write ([x exception] out)
  (print-to out x::msg))

;; Additional interfaces.

(defct %rpl-form (expr in-while cleanups)
  (if (or (not (cons-p expr))
          (not (cons-p (setq expr (macroexp expr)))))
    (return expr))
  (let arg (car expr)
    (if
      (is 'fct arg)
        (return expr)
      (table-p arg)
        (recur (table-items arg) in-while cleanups)
      (isa arg array-t tuple-t)
        (each val arg
          (recur val in-while cleanups))
      (or (is 'return arg) (and (not in-while) (is 'break arg)))
        (let gs (gensym)
          (setq expr
            `(,arg
               (let ,gs ,(cadr expr)
                 ,@cleanups
                 ,gs))))
      (is 'while arg)
        (setq expr
          (list* arg
                 (recur (cadr expr) in-while cleanups)
                 (recur (caddr expr) t cleanups)
                 (cdddr expr)))
      (cons-p arg)
        (let rv (recur arg in-while cleanups)
          (if (not (is rv arg))
            (setq expr (cons rv (cdr expr))))))
    (let rv (recur (cdr expr) in-while cleanups)
      (if (is rv (cdr expr))
        expr
        (cons (car expr) rv)))))

(defmac guard (expr . cleanup)
  (let (lerr (gensym) rv (gensym))
    `(let (,rv nil ,lerr nil)
       (try
         (setq ,rv (do ,(%rpl-form expr nil cleanup)))
         (setq ,lerr (last-err t)))
       ,@cleanup
       (if ,lerr
         (raise (car ,lerr) (cadr ,lerr))
         ,rv))))

;; Entry point for cleanups in 'with' forms.
(defmeth g-cleanup (x))

(defmac with (bindings . body)
  (let (iexpr ((fct (curr acc)
                 (if (not curr)
                   (nreverse acc)
                   (recur (cddr curr)
                          (list* nil (car curr) acc))))
               bindings nil)
        gcl (gensym)
        cleanup ((fct (curr acc clfn)
                   (if (not curr)
                     (nreverse acc)
                     (recur (cddr curr)
                            (cons (list clfn (car curr)) acc)
                            clfn)))
                 bindings nil gcl))
    `(let (,@iexpr
           ,gcl ::g-cleanup)
       (guard
         (do
           (setf ,@bindings)
           ,@body)
         ,@cleanup)
) ) )

(defct lazy-map (fn seq1 . seqn)
  (if (not seqn)
    (each val seq1
      (yield (fn val)))
    (let (iters (#'array (%map-list iter (cons seq1 seqn)))
          nseq (len iters)
          args (* nseq '[()]))
      (until (find iters nil)
        (let i 0
          (while (< i nseq)
            (nput args i (coro-val (iters i)))
            (nput iters i (coro-next (iters i)))
            (addf i)))
        (yield (#'fn args))))))

(defct map (fn seq1 . seqn)
  (tolist (#'lazy-map fn seq1 seqn)))

(defct zip (seq1 seq2 . seqn)
  (#'lazy-map list seq1 seq2 seqn))

(defct take (n seq)
  (let (rv nil itx (iter seq))
    (while (and itx (> n 0))
      (lpushf rv (coro-val itx))
      (setf it (coro-next itx))
      (subf n))
    (nreverse rv)))
